home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / pict-views.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  6.1 KB  |  183 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;;  pict-view.lisp
  4. ;;
  5. ;;  these define a subclass of pict-view called pict-view, which cache their
  6. ;;  image as a pict.  
  7.  
  8. (in-package :ccl)
  9.  
  10. (export '(pict-view with-pict-view with-rectangle-arg set-pict-cache view-close erase-view)
  11.         'ccl)
  12.  
  13. (eval-when (eval compile)
  14.   (require :deftrap)
  15.   (require-interface :quickdraw))
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;;;
  19. ;;; macros defined first
  20.  
  21. (defmacro with-rectangle-arg ((var left &optional top right bottom) &body body)
  22.   "takes a rectangle, two points, or four coordinates and makes a rectangle.
  23. body is evaluated with VAR bound to that rectangle."
  24.   (let ((left-var (make-symbol "LEFT"))
  25.         (top-var (make-symbol "TOP"))
  26.         (right-var (make-symbol "RIGHT"))
  27.         (bottom-var (make-symbol "BOTTOM")))
  28.     `(let ((,left-var ,left)
  29.            (,top-var ,top)
  30.            (,right-var ,right)
  31.            (,bottom-var ,bottom))
  32.        (call-with-rectangle-arg
  33.         #'(lambda (,var)
  34.             (declare (downward-function))
  35.             ,@body)
  36.         ,left-var ,top-var ,right-var ,bottom-var))))
  37.  
  38. (defun call-with-rectangle-arg (thunk left top right bottom)
  39.   (rlet ((var :rect))
  40.     (cond (bottom
  41.            (rset var rect.topleft (make-point left top))
  42.             (rset var rect.bottomright (make-point right bottom)))
  43.            (right
  44.             (error "Illegal rectangle arguments: ~s ~s ~s ~s"
  45.                    left top right bottom))
  46.            (top
  47.             (rset var rect.topleft (make-point left nil))
  48.             (rset var rect.bottomright (make-point top nil)))
  49.            (t (%setf-macptr var left)))
  50.     (funcall thunk var)))
  51.  
  52. ;; the macro with-pict-view evaluates forms while saving a picture
  53. ;; in the view-pict cache
  54.  
  55. (defmacro with-pict-view (view bottom-right &body body)
  56.   `(without-interrupts                              ;; don't want to redraw window now!
  57.     (with-focused-view view
  58.       (erase-view ,view)
  59.       (unwind-protect (progn
  60.                         (record-picture ,view ,bottom-right)
  61.                         ,@body)
  62.         (set-pict-cache ,view (get-picture ,view))))))
  63.  
  64. (defmacro with-view (view &body body)
  65.   "Like with-view except that the clip-rect is not set"
  66.   `(with-port (wptr ,view)
  67.      ,@body))
  68.  
  69. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70. ;;;
  71. ;;; the class pict-view is defined here
  72.  
  73. (defclass pict-view (simple-view) 
  74.   ((view-pict :accessor view-pict 
  75.               :initarg :view-pict 
  76.               :initform nil)))
  77.  
  78. (defmethod record-picture ((view pict-view) bottom-right)
  79.   (let ((wptr (wptr view)))
  80.     (unless (%null-ptr-p (rref wptr windowRecord.picsave))
  81.       (error "A picture may not be started for window: ~a.
  82.            since one is already started" view))
  83.     (rlet ((r ((r :rect))))
  84.       (rset r rect.topleft #@(0 0))
  85.       (rset r rect.bottomright bottom-right)
  86.       (#_cliprect r)
  87.       (setf (view-get view 'my-hPic) (#_OpenPicture r)))
  88.     nil))
  89.  
  90. (defmethod display-picture ((view pict-view) picture)
  91.   "A method internal to pict-views"
  92.   (let ((topleft (rref picture picture.picFrame.topleft))
  93.         (botright (rref picture picture.picFrame.bottomright)))
  94.     (with-rectangle-arg (r topleft botright)
  95.       (with-focused-view view
  96.         (rlet ((cr :rect :topleft (view-origin view) :bottomright (add-points (view-origin view) (view-size view))))
  97.           (#_cliprect cr))
  98.         (#_DrawPicture picture r))))
  99.   picture)
  100.  
  101.  
  102. (defmethod erase-view ((view pict-view))
  103.   "Calls erase-rect on the view rect defined by view"
  104.   (let ((view-origin (view-scroll-position view)))
  105.     (with-rectangle-arg (r view-origin (add-points (view-size view) view-origin))
  106.       (with-focused-view view
  107.         (#_EraseRect r)))))
  108.  
  109. (defmethod clear-pict-cache ((view pict-view))
  110.   "Clears the view-pict cache."
  111.   (let ((pict (view-pict view)))
  112.     (when pict
  113.       (#_KillPicture pict)
  114.       (setf (view-pict view) nil)))
  115.   (erase-view view))
  116.  
  117. (defmethod set-pict-cache ((view pict-view) pict)
  118.   "Draws pict in view and saves it in the view-pict cache"
  119.   (clear-pict-cache view)
  120.   (setf (view-pict view) pict)
  121.   (display-picture view pict))
  122.   
  123. (defmethod view-draw-contents ((view pict-view))
  124.   "Draw the pict cached in view-pict"
  125.   (let ((pict (view-pict view)))
  126.     (when pict
  127.       (display-picture view pict)))
  128.   (call-next-method))
  129.  
  130. (defmethod field-size ((view pict-view))
  131.   "Returns the size of the pict, if there is one"
  132.   (let ((pict (view-pict view)))
  133.     (if pict
  134.       (rref pict picture.picFrame.bottomright)
  135.       (call-next-method))))
  136.  
  137. (defmethod view-close ((view pict-view))
  138.   "Deallocates the pict cache"
  139.   (clear-pict-cache view)
  140. ;  (call-next-method)
  141.   )
  142.  
  143. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  144. ;;;
  145. ;;; Pictures get special treatment.  The following are used to record and display pictures;
  146. ;;; they handle the clip-region properly.
  147. ;;;
  148. ;;; The following have been modified for internal use by pict-views.  They should
  149. ;;; not be used for drawing into a pict-view
  150.  
  151. (defmethod get-picture ((view simple-view))
  152.   (let ((my-hPic (view-get view 'my-hPic))
  153.         (wptr (wptr view)))
  154.     (if (and my-hPic (not (%null-ptr-p (rref wptr windowRecord.picSave))))
  155.       (prog1
  156.         my-hPic
  157.         (with-port wptr (#_ClosePicture))
  158.         (setf (view-get view 'my-hPic) nil))
  159.       (error "Picture for window: ~a is not started" view))))
  160.  
  161. (defmethod draw-picture ((view pict-view) picture &optional left top right bottom)
  162.  (cond ((not left)
  163.         (setq left (rref picture picture.picFrame.topleft)
  164.               top (rref picture picture.picFrame.bottomright)))
  165.        ((pointerp left)
  166.         ())  ;everythings fine
  167.        ((and (not right)
  168.              (not top))
  169.         (setq top
  170.               (add-points left
  171.                           (subtract-points
  172.                            (rref picture picture.picframe.bottomright)
  173.                            (rref picture picture.picframe.topleft))))))
  174.  (with-rectangle-arg (r left top right bottom)
  175.    (with-view view
  176.      (#_DrawPicture picture r)))
  177.  picture)
  178.  
  179. (defun kill-picture (picture)
  180.   (#_KillPicture picture))
  181.  
  182. (provide :pict-views)
  183.